Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/Pascal/Games/On The Edge 3.0.1p/On The Edge.p

Text File | 1996-02-22 | 17.0 KB | 811 lines | [TEXT/PJMM]

{ On the Edge}
{}
{This is an extremely simple card game written by John Stiles. It is one of the smallest games}
{I've ever seen - 11k on disk after John added more color support - and is still a well-behaved}
{Mac application. I'd say that makes it an excellent demo to build games and other programs on.}
{The only problem was that John wrote it in C, but that weakness was easily fixed.}

program OnTheEdge;

    const
        Empty = $FF;

        mApple = 128;
        mFile = 129;
        mEdit = 130;
        iAbout = 1;
        iPlay = 1;
        iHelp = 2;
        iQuit = 4;
        iYes = 1;
        iNo = 2;

        msgSelectMultOf10 = 1;
        msgGameOver = 2;
        msgYouWin = 3;

        Jack = 11;
        Queen = 12;
        King = 13;

    function FindSuit (card: Integer): Integer;
    begin
        FindSuit := BitAnd(card, 3);
    end;

    function FindValue (card: Integer): Integer;
    begin
        FindValue := BSR(card, 2) + 1;
    end;

    var
        myWindow: WindowPtr;
        suits: Handle;
        deck: array[0..51] of Byte;
        grid: array[0..3, 0..3] of Byte;
        multiple: array[0..3, 0..3] of Boolean;
        deckPos: Byte;
        finished, gameInProgress, selectingMultiples: Boolean;
        colorQDAvail: Boolean;
        litGray, midGray, drkGray: RGBColor;

    function MakeRGBColor (r, g, b: Integer): RGBColor;
    begin
        MakeRGBColor.red := r;
        MakeRGBColor.green := g;
        MakeRGBColor.blue := b;
    end;

    function RandomBefore (what: Integer): Integer;
        var
            randomVal: Integer;
    begin
        randomVal := Random;

        if (randomVal < 0) then
            randomVal := -randomVal;

        randomVal := randomVal mod what;

        RandomBefore := randomVal;

    {And what's wrong with RandomBefore := Abs(Random) mod what; ?}
    end; {RandomBefore}

    procedure Shuffle;
        var
            count, count2, swap, temp: Integer;
    begin
        deckPos := 0;

        for count := 0 to 51 do
            begin
                deck[count] := count;
            end;

        for count2 := 1 to 20 do
            begin
                for count := 0 to 51 do
                    begin
                        swap := RandomBefore(52);
                        temp := deck[count];
                        deck[count] := deck[swap];
                        deck[swap] := temp;
                    end;
            end;
    end; {Shuffle}

    procedure EmptyGrid;
        var
            count, count2: Integer;
    begin
        for count := 0 to 3 do
            begin
                for count2 := 0 to 3 do
                    begin
                        grid[count][count2] := Empty;
                        multiple[count][count2] := false;
                    end;
            end;

        Shuffle;
    end; {EmptyGrid}

    procedure LabelGrid (horiz: Integer; vert: Integer);
        var
            message: Str255;
    begin
        GetIndString(message, 129, (vert * 4) + horiz + 1);

        TextFont(geneva);
        TextSize(9);

        if (colorQDAvail) then

            begin
                MoveTo(horiz * 64 + 21, vert * 64 + 37);
                ForeColor(whiteColor);
                DrawString(message);
            end;

        MoveTo(horiz * 64 + 20, vert * 64 + 36);
        ForeColor(redColor);
        DrawString(message);
    end; {LabelGrid}

    procedure OutlineButton (theDialog: DialogPtr; which: Integer);
        var
            itemType: Integer;
            itemHandle: Handle;
            itemRect: Rect;
    begin
        GetDItem(theDialog, which, itemType, itemHandle, itemRect);
        InsetRect(itemRect, -4, -4);
        PenSize(3, 3);
        FrameRoundRect(itemRect, 16, 16);
    end; {OutlineButton}

    procedure DrawSICN (var destRect: Rect; SICNhandle: Handle; which: Integer);
        var
            myBitMap: BitMap;
            srcRect: Rect;
    begin
        SetRect(srcRect, 0, 0, 16, 16);
        HLock(SICNhandle);

        myBitMap.rowBytes := 2;
        myBitMap.bounds := srcRect;
        myBitMap.baseAddr := Ptr(Longint(SICNhandle^) + (which * 32));

        CopyBits(myBitMap, myWindow^.portBits, srcRect, destRect, srcCopy, nil);

        HUnlock(SICNhandle);
    end; {DrawSICN}

    procedure DrawBWCard (var myRectP: Rect; mySuit: Integer; myValue: Integer);
        var
            myRect: Rect;
            disp: Str255;
    begin
        disp := 'A 2 3 4 5 6 7 8 9 10J Q K ';
        myRect := myRectP;

        InsetRect(myRect, 10, 5);

        if (myValue <= 13) then
            begin
                FrameRoundRect(myRect, 8, 8);

                TextFont(geneva);
                TextSize(12);
                MoveTo(myRect.left + 4, myRect.top + 15);
                DrawText(@disp[1], (myValue - 1) * 2, 2);

                myRect.bottom := myRect.bottom - 5;
                myRect.right := myRect.right - 5;
                myRect.top := myRect.bottom - 16;
                myRect.left := myRect.right - 16;

                if mySuit <= 1 then
                    ForeColor(redColor)
                else
                    ForeColor(blackColor);
                DrawSICN(myRect, suits, mySuit);
            end;
    end; {DrawBWCard}

    procedure DrawColorCard (var myRectP: Rect; mySuit: Integer; myValue: Integer);
        var
            myRect: Rect;
            disp: Str255;
            myRegion, tempRegion: RgnHandle;

    begin
        disp := 'A 2 3 4 5 6 7 8 9 10J Q K ';
        myRect := myRectP;

        InsetRect(myRect, 10, 5);

        if (myValue <= 13) then
            begin
                ForeColor(blackColor);
                FrameRoundRect(myRect, 8, 8);
                InsetRect(myRect, 1, 1);
                RGBForeColor(midGray);
                PaintRoundRect(myRect, 8, 8);


                ForeColor(whiteColor);
                FrameRoundRect(myRect, 8, 8);
                InsetRect(myRect, 1, 1);
                FrameRoundRect(myRect, 8, 8);

                tempRegion := NewRgn;
                myRegion := NewRgn;
                GetClip(tempRegion);

                OpenRgn;
                MoveTo(myRect.right + 1, myRect.top);
                LineTo(myRect.left, myRect.bottom + 1);
                LineTo(myRect.right + 1, myRect.bottom + 1);
                LineTo(myRect.right + 1, myRect.top);
                CloseRgn(myRegion);
                SetClip(myRegion);
                RGBForeColor(drkGray);
                FrameRoundRect(myRect, 8, 8);
                InsetRect(myRect, -1, -1);
                FrameRoundRect(myRect, 8, 8);

                SetClip(tempRegion);
                DisposeRgn(myRegion);
                DisposeRgn(tempRegion);

                InsetRect(myRect, -1, -1);

                TextFont(geneva);
                TextSize(12);

                ForeColor(whiteColor);
                MoveTo(myRect.left + 5, myRect.top + 16);
                DrawText(@disp[1], (myValue - 1) * 2, 2);

                ForeColor(blackColor);
                MoveTo(myRect.left + 4, myRect.top + 15);
                DrawText(@disp[1], (myValue - 1) * 2, 2);

                myRect.bottom := myRect.bottom - 5;
                myRect.right := myRect.right - 5;
                myRect.top := myRect.bottom - 16;
                myRect.left := myRect.right - 16;

                if mySuit <= 1 then
                    ForeColor(redColor)
                else
                    ForeColor(blackColor);
                RGBBackColor(midGray);
                DrawSICN(myRect, suits, mySuit);
            end;
    end; {DrawColorCard}

    procedure DrawCard (card: Byte; horiz: Integer; vert: Integer);
        var
            myRect: Rect;
            mySuit, myValue: Byte;
    begin
        myRect.top := vert * 64;
        myRect.bottom := myRect.top + 64;
        myRect.left := horiz * 64;
        myRect.right := myRect.left + 64;

        mySuit := FindSuit(card);
        myValue := FindValue(card);

        if (colorQDAvail) then
            DrawColorCard(myRect, mySuit, myValue)
        else
            DrawBWCard(myRect, mySuit, myValue);
    end; {DrawCard}

    procedure PromptMessage (messageID: Integer);
        var
            message: Str255;
    begin
        GetIndString(message, 128, messageID);

        SetPort(myWindow);
        MoveTo(20, 290);
        TextFont(systemFont);
        TextSize(12);
        ForeColor(blackColor);

        DrawString(message);
    end; {PromptMessage}

    procedure ClearMessage;
        var
            myRect: Rect;
    begin
        SetRect(myRect, 0, 257, 256, 320);
        BackColor(whiteColor);
        EraseRect(myRect);
    end; {ClearMessage}

    procedure DrawNewCard;
        var
            currentCard, cardValue: Integer;
    begin
        deckPos := deckPos + 1;
        currentCard := deck[deckPos];
        cardValue := FindValue(currentCard);
        DrawCard(currentCard, 3, 4);

        if (((cardValue = King) and not ((grid[0][0] = Empty) or (grid[0][3] = Empty) or (grid[3][0] = Empty) or (grid[3][3] = Empty))) or ((cardValue = Queen) and not ((grid[1][0] = Empty) or (grid[2][0] = Empty) or (grid[1][3] = Empty) or (grid[2][3] = Empty))) or ((cardValue = Jack) and not ((grid[0][1] = Empty) or (grid[0][2] = Empty) or (grid[3][1] = Empty) or (grid[3][2] = Empty)))) then
            begin
                gameInProgress := false;

                PromptMessage(msgGameOver);
            end;
    end; {DrawNewCard}

    procedure DrawSquare (x: Integer; y: Integer);
        var
            myRect: Rect;
    begin
        myRect.top := y * 64;
        myRect.bottom := myRect.top + 65;
        myRect.left := x * 64;
        myRect.right := myRect.left + 65;

        ForeColor(blueColor);
        FrameRect(myRect);

        InsetRect(myRect, 1, 1);
        if (colorQDAvail) then
            begin
                RGBBackColor(litGray);
                EraseRect(myRect);
                ForeColor(whiteColor);
                FrameRect(myRect);

                InsetRect(myRect, 1, 1);
                FrameRect(myRect);
                InsetRect(myRect, -1, -1);

                RGBForeColor(drkGray);
                MoveTo(myRect.right - 1, myRect.top);
                LineTo(myRect.right - 1, myRect.bottom - 1);
                LineTo(myRect.left, myRect.bottom - 1);
                LineTo(myRect.left + 1, myRect.bottom - 2);
                LineTo(myRect.right - 2, myRect.bottom - 2);
                LineTo(myRect.right - 2, myRect.top + 1);
            end
        else
            begin
                BackColor(whiteColor);
                EraseRect(myRect);
            end;
        InsetRect(myRect, -1, -1);

        if (grid[x][y] <> Empty) then
            begin
                DrawCard(grid[x][y], x, y);
                if (multiple[x][y]) then
                    begin
                        myRect.top := (y * 64) + 10;
                        myRect.left := (x * 64) + 30;
                        myRect.bottom := myRect.top + 16;
                        myRect.right := myRect.left + 16;

                        ForeColor(blueColor);

                        if (colorQDAvail) then
                            RGBBackColor(midGray)
                        else
                            BackColor(whiteColor);

                        DrawSICN(myRect, suits, 4);
                    end;
            end
        else
            begin
                LabelGrid(x, y);
            end;
    end; {DrawSquare}


    procedure FinishSelecting;
        var
            myRect: Rect;
            count, count2: Integer;
    begin
        ClearMessage;

        for count := 0 to 3 do
            begin
                for count2 := 0 to 3 do
                    begin
                        if (multiple[count][count2] = true) then
                            begin
                                multiple[count][count2] := false;
                                DrawSquare(count, count2);
                            end;

                        if (grid[count][count2] = Empty) then
                            begin
                                selectingMultiples := false;
                            end;
                    end;
            end;

        if (selectingMultiples) then
            begin
                gameInProgress := false;
                selectingMultiples := false;

                ClearMessage;
                PromptMessage(msgGameOver);

                Exit(FinishSelecting);
            end;

        DrawNewCard;
    end; {FinishSelecting}

    procedure SelectMultiples (var wherePtr: Point);
        var
            myRect: Rect;
            where: Point;
            total, count, count2: Integer;
    begin
        total := 0;
        where := wherePtr;

        where.h := BSR(where.h, 6);
        where.v := BSR(where.v, 6);

        if (where.v > 3) then
            begin
                FinishSelecting;
                Exit(SelectMultiples);
            end;

        for count := 0 to 3 do
            begin
                for count2 := 0 to 3 do
                    begin
                        if (multiple[count][count2]) then
                            total := total + FindValue(grid[count][count2]);
                    end;
            end;

        if (multiple[where.h][where.v]) then
            begin
                multiple[where.h][where.v] := false;
                DrawSquare(where.h, where.v);
                Exit(SelectMultiples);
            end
        else
            begin
                total := total + FindValue(grid[where.h][where.v]);

                if (total > 10) then
                    Exit(SelectMultiples);

                multiple[where.h][where.v] := true;
                DrawSquare(where.h, where.v);

                if (total = 10) then
                    for count := 0 to 3 do
                        for count2 := 0 to 3 do
                            if (multiple[count][count2]) then

                                begin
                                    grid[count][count2] := Empty;
                                    multiple[count][count2] := false;

                                    DrawSquare(count, count2);
                                end;
            end;
    end; {SelectMultiples}

    procedure StartSelecting;
    begin
        ClearMessage;

        PromptMessage(msgSelectMultOf10);
    end;

    procedure PlaceCards (var wherePtr: Point);
        var
            where: Point;
            currentCard, cardValue: Byte;
            count, count2: Integer;

    begin
        where := wherePtr;

        where.h := BSR(where.h, 6);
        where.v := BSR(where.v, 6);

        if (where.v > 3) then
            Exit(PlaceCards);

        if (grid[where.h][where.v] <> Empty) then
            Exit(PlaceCards);

        currentCard := deck[deckPos];
        cardValue := FindValue(currentCard);

{These huge if's could use some rewriting to be truly efficient.}

        if ((cardValue = King) and not (((where.h = 0) or (where.h = 3)) and ((where.v = 0) or (where.v = 3)))) then
            Exit(PlaceCards);

        if ((cardValue = Queen) and not (((where.h = 1) and (where.v = 0)) or ((where.h = 2) and (where.v = 0)) or ((where.h = 1) and (where.v = 3)) or ((where.h = 2) and (where.v = 3)))) then
            Exit(PlaceCards);

        if ((cardValue = Jack) and not (((where.h = 0) and (where.v = 1)) or ((where.h = 0) and (where.v = 2)) or ((where.h = 3) and (where.v = 1)) or ((where.h = 3) and (where.v = 2)))) then
            Exit(PlaceCards);

        grid[where.h][where.v] := currentCard;

        DrawCard(currentCard, where.h, where.v);

        if ((FindValue(grid[0][0]) = King) and (FindValue(grid[0][3]) = King) and (FindValue(grid[3][0]) = King) and (FindValue(grid[3][3]) = King) and (FindValue(grid[1][0]) = Queen) and (FindValue(grid[2][0]) = Queen) and (FindValue(grid[1][3]) = Queen) and (FindValue(grid[2][3]) = Queen) and (FindValue(grid[0][1]) = Jack) and (FindValue(grid[0][2]) = Jack) and (FindValue(grid[3][1]) = Jack) and (FindValue(grid[3][2]) = Jack)) then

            begin
                ClearMessage;

                PromptMessage(msgYouWin);

                gameInProgress := false;

                Exit(PlaceCards);
            end;

        selectingMultiples := true;
        for count := 0 to 3 do
            begin
                for count2 := 0 to 3 do
                    begin
                        if (grid[count][count2] = Empty) then
                            selectingMultiples := false;
                    end;
            end;

        if (selectingMultiples) then
            begin
                StartSelecting;
                Exit(PlaceCards);
            end;

        DrawNewCard;
    end;

    procedure RedrawWindow;
        var
            count, count2: Integer;
            myRect: Rect;
    begin
        for count := 0 to 3 do
            for count2 := 0 to 3 do
                DrawSquare(count2, count);

        if (selectingMultiples) then
            PromptMessage(msgSelectMultOf10)
        else if deckPos < 52 then
            DrawCard(deck[deckPos], 3, 4)
        else
            DrawCard(Empty, 3, 4);

        if (not gameInProgress) then
            PromptMessage(msgGameOver);
    end; {RedrawWindow}

    procedure Initialize;
        var
            thisSysInfo: SysEnvRec;
            err: OSErr;
    begin
{$IFC UNDEFINED THINK_PASCAL}
        MaxApplZone;
        MoreMasters;

        InitGraf(qd.thePort);
        InitFonts;
        FlushEvents(everyEvent, 0);
        InitWindows;
        InitMenus;
        TEInit;
        InitDialogs(nil);
        InitCursor;
{$ENDC}

{ GetDateTime( (unsigned long * ) & randSeed ) ); / / seed the random #    generator }
        GetDateTime(randSeed);
{was: GetDateTime( (LongInt ^)LMGetRndSeed );}

        err := SysEnvirons(curSysEnvVers, thisSysInfo);
        colorQDAvail := thisSysInfo.hasColorQD;

        litGray := MakeRGBColor($E000, $E000, $E000);
        midGray := MakeRGBColor($D000, $D000, $D000);
        drkGray := MakeRGBColor($A000, $A000, $A000);
    end; {Initialize}

    procedure RetrieveResources;
        var
            count: Integer;
            menuBar: Handle;
            menu: MenuHandle;

    { menus}

    begin
        menuBar := GetNewMBar(128);
        if (menuBar = nil) then
            begin
                SysBeep(1);
                ExitToShell;
            end;

        SetMenuBar(menuBar);

        menu := GetMHandle(mApple);
        AddResMenu(menu, 'DRVR');

        DrawMenuBar;

    { window}

        if (colorQDAvail) then
            myWindow := GetNewCWindow(128, nil, WindowPtr(-1))
        else
            myWindow := GetNewWindow(128, nil, WindowPtr(-1));

        if (myWindow = nil) then
            begin
                SysBeep(1);
                ExitToShell;
            end;
        ShowWindow(myWindow);
        SetPort(myWindow);

    { suit SICNs}

        suits := GetResource('SICN', 128);
    end;

    procedure StartGame;
        var
            myDialog: DialogPtr;
            response: Integer;
    begin
        if gameInProgress then
            begin
                myDialog := GetNewDialog(129, nil, WindowPtr(-1));

                ShowWindow(myDialog);
                SetPort(myDialog);

                OutlineButton(myDialog, iYes);

                ModalDialog(nil, response);

                DisposDialog(myDialog);

                if (response = iNo) then
                    Exit(StartGame);
            end;

        gameInProgress := true;

        selectingMultiples := false;

        EmptyGrid;

        SetPort(myWindow);
        BackColor(whiteColor);
        EraseRect((myWindow^.portRect));
        RedrawWindow;
    end; {StartGame}

    procedure HandleMenus (selection: LongInt);
        var
            menu, item, i: Integer;
            appleMenu: MenuHandle;
            deskAccessory: Str255;
    begin
        menu := BSR(selection, 16);
        item := selection;
        case menu of
            mApple:
                if (item = iAbout) then
                    begin
                        i := Alert(128, nil);
                    end
                else
                    begin
                        appleMenu := GetMHandle(mApple);
                        GetItem(appleMenu, item, deskAccessory);
                        i := OpenDeskAcc(deskAccessory);
                    end;

            mFile:
                case item of
                    iPlay:
                        StartGame;
                    iHelp:
                        begin
                            i := Alert(130, nil);
                            i := Alert(131, nil);
                        end;

                    iQuit:
                        finished := true;
                end; {case item}
            mEdit:
                ;
        end; {case menu}
        HiliteMenu(0);
    end; {HandleMenus}

    procedure HandleClick (var wherePtr: Point);
    begin
        if (gameInProgress) then
            begin
                if (selectingMultiples) then
                    SelectMultiples(wherePtr)
                else
                    PlaceCards(wherePtr);
            end;
    end;

    procedure EventLoop;
        var
            e: EventRecord;
            window: WindowPtr;
            part: Integer;
    begin
        repeat
            begin
{$IFC UNDEFINED THINK_PASCAL}
                SetCursor(qd.arrow);
{$ELSEC}
                SetCursor(arrow);
{$ENDC}
                if WaitNextEvent(everyEvent, e, -1, nil) then
                    case e.what of
                        keyDown:
                            if BAnd(e.modifiers, cmdKey) <> 0 then
                                HandleMenus(MenuKey(Char(BAnd(e.message, charCodeMask))));
                        mouseDown:
                            begin
                                part := FindWindow(e.where, window);
                                case part of
                                    inDrag:
{$IFC UNDEFINED THINK_PASCAL}
                                        DragWindow(window, e.where, qd.screenBits.bounds);
{$ELSEC}
                                    DragWindow(window, e.where, screenBits.bounds);
{$ENDC}

                                    inMenuBar:
                                        HandleMenus(MenuSelect(e.where));

                                    inSysWindow:
                                        SystemClick(e, window);

                                    inContent:
                                        begin
                                            SetPort(window);
                                            GlobalToLocal(e.where);
                                            HandleClick(e.where);
                                        end;
                                end; {case part}
                            end;

                        updateEvt:
                            begin
                                BeginUpdate(WindowPtr(e.message));
                                SetPort(WindowPtr(e.message));
                                RedrawWindow;
                                EndUpdate(WindowPtr(e.message));
                            end;
                    end; {case what}
            end; {repeat}
        until finished;
    end; {EventLoop}

{Main program}
begin
    Initialize;

    RetrieveResources;

    EmptyGrid;

    repeat
        EventLoop;
    until finished;
end.